home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / clisp_c.zoo / init.lsp < prev    next >
Text File  |  1993-06-05  |  66KB  |  1,586 lines
  1. ;;;;   INITIALISIERUNGS-FILE
  2.  
  3. (in-package "LISP")
  4.  
  5. ;;; Exportierungen:
  6. (export '(
  7. ;; Typen:
  8. array atom bignum bit bit-vector character common compiled-function
  9. complex cons double-float fixnum float function hash-table integer keyword
  10. list long-float nil null number package pathname random-state ratio
  11. rational readtable real sequence short-float simple-array simple-bit-vector
  12. simple-string simple-vector single-float standard-char stream string
  13. string-char symbol t vector satisfies values mod signed-byte unsigned-byte
  14. ;; Konstanten:
  15. lambda-list-keywords lambda-parameters-limit nil t call-arguments-limit
  16. multiple-values-limit pi boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2
  17. boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor boole-andc1
  18. boole-andc2 boole-orc1 boole-orc2 most-positive-fixnum most-negative-fixnum
  19. most-positive-short-float least-positive-short-float least-negative-short-float
  20. most-negative-short-float most-positive-single-float
  21. least-positive-single-float least-negative-single-float
  22. most-negative-single-float most-positive-double-float
  23. least-positive-double-float least-negative-double-float
  24. most-negative-double-float most-positive-long-float least-positive-long-float
  25. least-negative-long-float most-negative-long-float short-float-epsilon
  26. single-float-epsilon double-float-epsilon long-float-epsilon
  27. short-float-negative-epsilon single-float-negative-epsilon
  28. double-float-negative-epsilon long-float-negative-epsilon
  29. char-code-limit char-font-limit char-bits-limit char-control-bit char-meta-bit
  30. char-super-bit char-hyper-bit array-rank-limit array-dimension-limit
  31. array-total-size-limit internal-time-units-per-second
  32. ;; Variablen:
  33. *macroexpand-hook* *package* *modules* *random-state* *evalhook* *applyhook*
  34. + ++ +++ - * ** *** / // /// *standard-input* *standard-output* *error-output*
  35. *query-io* *debug-io* *terminal-io* *trace-output* *read-base* *read-suppress*
  36. *readtable* *print-escape* *print-pretty* *print-circle* *print-base*
  37. *print-radix* *print-case* *print-gensym* *print-level* *print-length*
  38. *print-array* *read-default-float-format* *default-pathname-defaults*
  39. *load-paths* *load-verbose* *load-print* *load-echo* *break-on-warnings*
  40. *features*
  41. ;; Funktionen:
  42. coerce type-of upgraded-array-element-type typep subtypep null symbolp
  43. atom consp listp numberp integerp rationalp floatp realp complexp characterp
  44. stringp bit-vector-p vectorp simple-vector-p simple-string-p
  45. simple-bit-vector-p arrayp packagep functionp compiled-function-p commonp eq
  46. eql equal equalp not symbol-value symbol-function boundp fboundp
  47. special-form-p set makunbound fmakunbound get-setf-method
  48. get-setf-method-multiple-value apply funcall mapcar maplist mapc mapl mapcan
  49. mapcon values values-list macro-function macroexpand macroexpand-1 proclaim
  50. get remprop symbol-plist getf get-properties symbol-name make-symbol
  51. copy-symbol gensym gentemp symbol-package keywordp make-package in-package
  52. find-package package-name package-nicknames rename-package package-use-list
  53. package-used-by-list package-shadowing-symbols list-all-packages intern
  54. find-symbol unintern export unexport import shadowing-import shadow
  55. use-package unuse-package find-all-symbols provide require zerop plusp minusp
  56. oddp evenp = /= < > <= >= max min + - * / 1+ 1- conjugate gcd lcm exp expt
  57. log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh cosh tanh
  58. asinh acosh atanh float rational rationalize numerator denominator floor
  59. ceiling truncate round mod rem ffloor fceiling ftruncate fround decode-float
  60. scale-float float-radix float-sign float-digits float-precision
  61. integer-decode-float complex realpart imagpart logior logxor logand logeqv
  62. lognand lognor logandc1 logandc2 logorc1 logorc2 lognot logtest logbitp ash
  63. logcount integer-length byte byte-size byte-position ldb ldb-test mask-field
  64. dpb deposit-field random make-random-state random-state-p standard-char-p
  65. graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p
  66. both-case-p digit-char-p alphanumericp char= char/= char< char> char<= char>=
  67. char-equal char-not-equal char-lessp char-greaterp char-not-greaterp
  68. char-not-lessp char-code char-bits char-font code-char make-char character
  69. char-upcase char-downcase digit-char char-int int-char char-name name-char
  70. char-bit set-char-bit elt subseq copy-seq length reverse nreverse
  71. make-sequence concatenate map some every notany notevery reduce fill replace
  72. remove remove-if remove-if-not delete delete-if delete-if-not
  73. remove-duplicates delete-duplicates substitute substitute-if
  74. substitute-if-not nsubstitute nsubstitute-if nsubstitute-if-not find find-if
  75. find-if-not position position-if position-if-not count count-if count-if-not
  76. mismatch search sort stable-sort merge car cdr caar cadr cdar cddr caaar
  77. caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
  78. cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  79. cons tree-equal endp list-length nth first second third fourth fifth sixth
  80. seventh eighth ninth tenth rest nthcdr last list list* make-list append
  81. copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff
  82. rplaca rplacd subst subst-if subst-if-not nsubst nsubst-if-not sublis nsublis
  83. member member-if member-if-not tailp adjoin union nunion intersection
  84. nintersection set-difference nset-difference set-exclusive-or
  85. nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc
  86. rassoc-if rassoc-if-not make-hash-table hash-table-p gethash remhash maphash
  87. clrhash hash-table-count sxhash make-array vector aref svref
  88. array-element-type array-rank array-dimension array-dimensions
  89. array-total-size array-in-bounds-p array-row-major-index adjustable-array-p
  90. bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
  91. bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p fill-pointer vector-push
  92. vector-push-extend vector-pop adjust-array char schar string= string-equal
  93. string< string> string<= string>= string/= string-lessp string-greaterp
  94. string-not-greaterp string-not-lessp string-not-equal make-string string-trim
  95. string-left-trim string-right-trim string-upcase string-downcase
  96. string-capitalize nstring-upcase nstring-downcase nstring-capitalize string
  97. eval evalhook applyhook constantp make-synonym-stream make-broadcast-stream
  98. make-concatenated-stream make-two-way-stream make-echo-stream
  99. make-string-input-stream make-string-output-stream get-output-stream-string
  100. streamp input-stream-p output-stream-p stream-element-type interactive-stream-p
  101. close copy-readtable readtablep set-syntax-from-char set-macro-character
  102. get-macro-character make-dispatch-macro-character
  103. set-dispatch-macro-character get-dispatch-macro-character read
  104. read-preserving-whitespace read-delimited-list read-line read-char
  105. unread-char peek-char listen read-char-no-hang clear-input read-from-string
  106. parse-integer read-byte write prin1 print pprint princ write-to-string
  107. prin1-to-string princ-to-string write-char write-string write-line terpri
  108. fresh-line finish-output force-output clear-output write-byte format y-or-n-p
  109. yes-or-no-p pathname truename parse-namestring merge-pathnames make-pathname
  110. pathnamep pathname-host pathname-device pathname-directory pathname-name
  111. pathname-type pathname-version namestring file-namestring
  112. directory-namestring host-namestring enough-namestring user-homedir-pathname
  113. open rename-file delete-file probe-file file-write-date file-author
  114. file-position file-length load directory error cerror warn break compile
  115. compile-file disassemble
  116. documentation  variable structure type ; drei Dokumentations-Typen
  117. describe inspect room ed dribble apropos apropos-list get-decoded-time
  118. get-universal-time decode-universal-time encode-universal-time
  119. get-internal-run-time get-internal-real-time sleep lisp-implementation-type
  120. lisp-implementation-version machine-type machine-version machine-instance
  121. software-type software-version short-site-name long-site-name identity
  122. ;; Special-forms:
  123. eval-when quote function setq progn let let* compiler-let progv flet labels
  124. macrolet if block return-from tagbody go multiple-value-call
  125. multiple-value-prog1 catch unwind-protect throw declare the load-time-value
  126. ;; Macros:
  127. deftype defun defvar defparameter defconstant and or psetq setf psetf shiftf
  128. rotatef define-modify-macro defsetf define-setf-method prog1 prog2
  129. when unless cond
  130. case typecase  otherwise ; otherwise als Marker für die catchall-clause
  131. return loop do do* dolist dotimes prog prog* multiple-value-list
  132. multiple-value-bind multiple-value-setq defmacro locally remf do-symbols
  133. do-external-symbols do-all-symbols incf decf push pushnew pop defstruct
  134. with-open-stream with-input-from-string with-output-to-string with-open-file
  135. check-type assert etypecase ctypecase ecase ccase trace untrace step time
  136. ;; sonstige Markierer:
  137. eval load compile ; EVAL-WHEN-Situationen
  138. special type ftype function inline notinline ignore optimize speed space
  139. safety compilation-speed declaration compile ; DECLARE-Specifier
  140. interpreter compiler ; Features
  141. ))
  142.  
  143. (sys::%proclaim-constant 'lambda-list-keywords
  144.   '(&optional &rest &key &allow-other-keys &aux &body &whole &environment)
  145. )
  146. (export lambda-list-keywords)
  147.  
  148. (sys::%putd 'exit #'sys::%exit)
  149. (sys::%putd 'quit #'sys::%exit)
  150. (sys::%putd 'bye #'sys::%exit)
  151. (export '(exit quit bye))
  152.  
  153. (proclaim '(special *features*))
  154. ; Nach der Initialisierung (in IO.Q bzw. SPVW.D) enthält *features*
  155. ; als drittes Symbol  (first (sys::version)) = SYS::CLISP1/2/3
  156. ; und als letztes Symbol  (intern *language* "LISP").
  157. (import *features*)
  158. (export *features*)
  159.  
  160. (in-package "SYSTEM" :nicknames '("SYS" "COMPILER"))
  161. (setq compiler::*compiling* nil)
  162.  
  163. (in-package "SYSTEM")
  164.  
  165. #-COMPILER ; nur beim Bootstrappen
  166. (progn
  167.  
  168. ; vorläufig soll bei GET_CLOSURE nicht expandiert werden:
  169. (sys::%putd '%expand-lambdabody-main
  170.   (function %expand-lambdabody-main
  171.     (lambda (lambdabody fenv)
  172.       (declare (source nil) (ignore fenv))
  173.       lambdabody
  174. ) ) )
  175.  
  176. ; vorläufig soll defun ganz trivial expandiert werden:
  177. (sys::%putd 'defun
  178.   (cons 'sys::macro
  179.     (function defun
  180.       (lambda (form env)
  181.         (declare (ignore env))
  182.         #|
  183.         (let ((name (cadr form))
  184.               (lambdalist (caddr form))
  185.               (body (cdddr form)))
  186.           `(SYS::%PUTD ',name (FUNCTION ,name (LAMBDA ,lambdalist ,@body)))
  187.         )
  188.         |#
  189.         (let ((name (cadr form)))
  190.           (list 'sys::%putd (list 'quote name)
  191.             (list 'function name (cons 'lambda (cddr form)))
  192.         ) )
  193.     ) )
  194. ) )
  195.  
  196. )
  197.  
  198. (sys::%putd 'sys::remove-old-definitions
  199.   (function sys::remove-old-definitions
  200.     (lambda (symbol) ; entfernt die alten Funktionsdefinitionen eines Symbols
  201.       (if (special-form-p symbol)
  202.         (error #+DEUTSCH "~S ist eine Special-Form und darf nicht umdefiniert werden."
  203.                #+ENGLISH "~S is a special form and may not be redefined."
  204.                #+FRANCAIS "~S est une forme spéciale et ne peut pas être redéfinie."
  205.                symbol
  206.       ) )
  207.       (if (and (or (fboundp symbol) (macro-function symbol))
  208.                (let ((pack (symbol-package symbol)))
  209.                  (and pack (equal (package-name pack) "LISP"))
  210.           )    )
  211.         (cerror #+DEUTSCH "Die alte Definition wird weggeworfen."
  212.                 #+ENGLISH "The old definition will be lost"
  213.                 #+FRANCAIS "L'ancienne définition sera perdue."
  214.                 #+DEUTSCH "D~2@*~:[ie~;er~]~0@* COMMON-LISP-~A ~S wird umdefiniert."
  215.                 #+ENGLISH "Redefining the COMMON LISP ~A ~S"
  216.                 #+FRANCAIS "L~2@*~:[a~;e~]~0@* ~A ~S de COMMON-LISP va être redéfini~:[e~;~]."
  217.                 (fbound-string symbol) ; "Funktion" bzw. "Macro"
  218.                 symbol
  219.                 #+(or DEUTSCH FRANCAIS) (macro-function symbol)
  220.       ) )
  221.       (fmakunbound symbol) ; Funktions-/Macro-Definition streichen
  222.       ; Property sys::definition wird nicht entfernt, da sie sowieso
  223.       ; bald neu gesetzt wird.
  224.       (remprop symbol 'sys::macro) ; Macro-Definition streichen
  225.       (when (get symbol 'sys::documentation-strings) ; Dokumentation streichen
  226.         (sys::%set-documentation symbol 'FUNCTION nil)
  227.       )
  228.       (when (get symbol 'sys::inline-expansion)
  229.         (sys::%put symbol 'sys::inline-expansion t)
  230.       )
  231.       (when (get symbol 'sys::traced-definition) ; Trace streichen
  232.         (warn #+DEUTSCH "DEFUN/DEFMACRO: ~S war getraced und wird umdefiniert!"
  233.               #+ENGLISH "DEFUN/DEFMACRO: redefining ~S; it was traced!"
  234.               #+FRANCAIS "DEFUN/DEFMACRO : ~S était tracée et est redéfinie!"
  235.               symbol
  236.         )
  237.         (untrace2 symbol)
  238.     ) )
  239. ) )
  240.  
  241. ;;; Funktionen zum Expandieren von Macros innerhalb eines Codestückes
  242. ;;;
  243. ;;; Insgesamt wird der gesamte Code (einer Funktion) durchgegangen und
  244. ;;; globale und lokale Macros expandiert.
  245. ;;; Aus       #'(lambda lambdalist . body)
  246. ;;; wird so   #'(lambda expanded-lambdalist
  247. ;;;               (declare (source (lambdalist . body))) . expanded-body
  248. ;;;             )
  249. ;;; Durch diese Deklaration ist gewährleistet, daß eine bereits einmal
  250. ;;; durchlaufene Funktion als solche erkannt und nicht unnötigerweise ein
  251. ;;; zweites Mal durchlaufen wird.
  252.  
  253. ; Vorsicht! Fürs Bootstrappen (erkennbar an #-COMPILER) müssen manche der
  254. ; Funktionen in primitiverem Lisp (ohne do, do*, case) geschrieben werden.
  255.  
  256. (PROGN
  257.  
  258. (proclaim '(special *keyword-package*))
  259. (setq *keyword-package* (find-package "KEYWORD"))
  260.  
  261. (proclaim '(special *fenv*))
  262. ; *fenv* = Das aktuelle Function-Environment während der Expansion
  263. ; einer Form. Struktur: NIL oder ein 2n+1-elementiger Vektor
  264. ; (n1 f1 ... nn fn next), wo die ni Symbole sind, die fi ihre funktionale
  265. ; Bedeutung sind (Closure oder (MACRO . Closure) oder noch NIL); bei next
  266. ; geht's ebenso weiter.
  267.  
  268. ; (fenv-assoc s fenv) sucht Symbol s in Function-Environment fenv.
  269. (defun fenv-assoc (s fenv)
  270.   (if fenv
  271.     (if (simple-vector-p fenv)
  272.       #+COMPILER
  273.       (do ((l (1- (length fenv)))
  274.            (i 0 (+ i 2)))
  275.           ((= i l) (fenv-assoc s (svref fenv i)))
  276.         (if (eq s (svref fenv i))
  277.           (return (svref fenv (1+ i)))
  278.       ) )
  279.       #-COMPILER
  280.       (let ((l (1- (length fenv)))
  281.             (i 0))
  282.         (block nil
  283.           (tagbody
  284.             1 (if (= i l) (return-from nil (fenv-assoc s (svref fenv i))))
  285.               (if (eq s (svref fenv i))
  286.                 (return-from nil (svref fenv (1+ i)))
  287.               )
  288.               (setq i (+ i 2))
  289.               (go 1)
  290.       ) ) )
  291.       (error #+DEUTSCH "~S ist kein korrektes Function-Environment."
  292.              #+ENGLISH "~S is an invalid function environment"
  293.              #+FRANCAIS "~S n'est pas un environnement de fonction correct."
  294.              fenv
  295.     ) )
  296.     'T ; nicht gefunden
  297. ) )
  298.  
  299. ; Die meisten Expansionsfunktionen liefern zwei Werte: Das Expansions-
  300. ; ergebnis, der zweite Wert (NIL oder T) zeigt an, ob darin etwas verändert
  301. ; wurde.
  302.  
  303. ; (%expand-cons ...) setzt ein cons zusammen. 2 Werte.
  304. ; form=alte Form,
  305. ; expf,flagf = Expansion des First-Teils,
  306. ; expr,flagr = Expansion des Rest-Teils.
  307. (defun %expand-cons (form expf flagf expr flagr)
  308.   (if (or flagf flagr)
  309.     (values (cons expf expr) t)
  310.     (values form nil)
  311. ) )
  312.  
  313. #+COMPILER
  314.  
  315. ; (%expand-form form) expandiert eine ganze Form. 2 Werte.
  316. (defun %expand-form (form)
  317.   (if (atom form)
  318.     (values form nil)
  319.     ; form ist CONS
  320.     (let ((f (first form)))
  321.       (if (symbolp f)
  322.         (let ((h (fenv-assoc f *fenv*)))
  323.           ; f ist in *fenv* assoziiert zu h
  324.           (if (eq h 'T)
  325.             ; f hat keine lokale Definition
  326.             ; Nun die einzelnen Expander für die Special-forms:
  327.             (case f
  328.               ((RETURN-FROM THE MULTIPLE-VALUE-SETQ MULTIPLE-VALUE-BIND
  329.                 DEFVAR DEFPARAMETER DEFCONSTANT
  330.                )
  331.                 ; 1. Argument lassen, alle weiteren expandieren
  332.                 (multiple-value-call #'%expand-cons form
  333.                   (first form) nil
  334.                   (multiple-value-call #'%expand-cons (rest form)
  335.                     (second form) nil
  336.                     (%expand-list (cddr form))
  337.               ) ) )
  338.               ((QUOTE GO DECLARE LOAD-TIME-VALUE) ; nichts expandieren
  339.                 (values form nil)
  340.               )
  341.               (FUNCTION
  342.                 ; Falls erstes bzw. zweites Argument Liste,
  343.                 ; als Lambda-Ausdruck expandieren.
  344.                 (multiple-value-call #'%expand-cons form
  345.                   'FUNCTION nil
  346.                   (if (atom (cddr form))
  347.                     (if (atom (second form))
  348.                       (if (symbolp (second form))
  349.                         (let ((h (fenv-assoc (second form) *fenv*)))
  350.                           (cond ((or (eq h 'T) (closurep h) (null h)) (values (rest form) nil))
  351.                                 ((and (consp h) (eq (first h) 'MACRO))
  352.                                  (error #+DEUTSCH "~S: ~S unzulässig, da ~S ein lokaler Macro ist"
  353.                                         #+ENGLISH "~S: ~S is illegal since ~S is a local macro"
  354.                                         #+FRANCAIS "~S : ~S est illégal car ~S est un macro local"
  355.                                         '%expand form (second form)
  356.                                 ))
  357.                                 (t (error #+DEUTSCH "~S: Falscher Aufbau eines Function-Environment: ~S"
  358.                                           #+ENGLISH "~S: invalid function environment ~S"
  359.                                           #+FRANCAIS "~S : mauvais environnement de fonction ~S"
  360.                                           '%expand *fenv*
  361.                                 )  )
  362.                         ) )
  363.                         (error #+DEUTSCH "~S: ~S unzulässig, da ~S kein Symbol"
  364.                                #+ENGLISH "~S: ~S is invalid since ~S is not a symbol"
  365.                                #+FRANCAIS "~S : ~S est illégal car ~S n'est pas un symbole"
  366.                                '%expand form (second form)
  367.                       ) )
  368.                       (multiple-value-call #'%expand-cons (rest form)
  369.                         (%expand-lambda (second form))
  370.                         (cddr form) nil
  371.                     ) )
  372.                     (multiple-value-call #'%expand-cons (rest form)
  373.                       (second form) nil
  374.                       (multiple-value-call #'%expand-cons (cddr form)
  375.                         (%expand-lambda (third form))
  376.                         (cdddr form) nil
  377.               ) ) ) ) )
  378.               (EVAL-WHEN
  379.                 ; Falls die Situation COMPILE angegeben ist, führe den Body
  380.                 ; als PROGN aus, gib eine Form zurück, die ohne Seiteneffekte
  381.                 ; dieselben Werte liefert.
  382.                 ; Sonst expandiere alle Argumente ab dem zweiten als Formen.
  383.                 (if (member 'COMPILE (second form))
  384.                   (values
  385.                     (list 'values-list
  386.                       (list 'quote
  387.                         (multiple-value-list (eval (cons 'PROGN (cddr form))))
  388.                     ) )
  389.                     t
  390.                   )
  391.                   (multiple-value-call #'%expand-cons form
  392.                     (first form) nil
  393.                     (multiple-value-call #'%expand-cons (rest form)
  394.                       (second form) nil
  395.                       (%expand-list (cddr form))
  396.               ) ) ) )
  397.               ((LET LET*) ; Variablenliste und Body expandieren
  398.                 (multiple-value-call #'%expand-cons form
  399.                   (first form) nil
  400.                   (multiple-value-call #'%expand-cons (rest form)
  401.                     (%expand-varspez (second form))
  402.                     (%expand-list (cddr form))
  403.               ) ) )
  404.               (COMPILER-LET
  405.                 ; Variablenliste im leeren Environment und Body expandieren
  406.                 (progv
  407.                   (mapcar #'%expand-varspec-var (second form))
  408.                   (mapcar #'%expand-varspec-val (second form))
  409.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  410.               ) )
  411.               (COND ; Alle Teilformen der Klauseln expandieren:
  412.                 (multiple-value-call #'%expand-cons form
  413.                   (first form) nil
  414.                   (%expand-cond (rest form))
  415.               ) )
  416.               (BLOCK
  417.                 ; Body expandieren. Falls darin ein RETURN-FROM auf diesen
  418.                 ; Block vorkommt, behalte BLOCK. Sonst mache ein PROGN daraus.
  419.                 (multiple-value-bind (body flagb) (%expand-list (cddr form))
  420.                   (if (%return-p (second form) body)
  421.                     (multiple-value-call #'%expand-cons form
  422.                       (first form) nil
  423.                       (multiple-value-call #'%expand-cons (rest form)
  424.                         (second form) nil
  425.                         body flagb
  426.                     ) )
  427.                     (values
  428.                       (cond ((atom body) body)
  429.                             ((null (cdr body)) (car body))
  430.                             (t (cons 'progn body))
  431.                       )
  432.                       t
  433.               ) ) ) )
  434.               ((SETQ PSETQ) ; jedes zweite Argument expandieren
  435.                 (multiple-value-call #'%expand-cons form
  436.                   (first form) nil
  437.                   (%expand-setqlist (rest form))
  438.               ) )
  439.               (TAGBODY
  440.                 ; alle Argumente expandieren, dabei entstehende Atome weglassen
  441.                 (multiple-value-call #'%expand-cons form
  442.                   (first form) nil
  443.                   (%expand-tagbody (rest form))
  444.               ) )
  445.               (PROGN ; alle Argumente expandieren, evtl. vereinfachen.
  446.                 (if (null (rest form))
  447.                   (values nil t)
  448.                   (if (null (cddr form))
  449.                     (values (%expand-form (second form)) t)
  450.                     (multiple-value-call #'%expand-cons form
  451.                       (first form) nil
  452.                       (%expand-list (rest form))
  453.               ) ) ) )
  454.               (FLET ; Funktionsdefinitionen expandieren,
  455.                     ; Body im erweiterten Environment expandieren
  456.                 (if (null (second form))
  457.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  458.                   (let ((newfenv (%expand-fundefs-1 (second form))))
  459.                     (multiple-value-call #'%expand-cons form
  460.                       (first form) nil
  461.                       (multiple-value-call #'%expand-cons (rest form)
  462.                         (%expand-fundefs-2 (second form))
  463.                         (let ((*fenv* (apply #'vector newfenv)))
  464.                           (%expand-list (cddr form))
  465.               ) ) ) ) ) )
  466.               (LABELS ; Funktionsdefinitionen und Body im erweiterten Environment expandieren
  467.                 (if (null (second form))
  468.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  469.                   (let ((newfenv (%expand-fundefs-1 (second form))))
  470.                     (let ((*fenv* (apply #'vector newfenv)))
  471.                       (multiple-value-call #'%expand-cons form
  472.                         (first form) nil
  473.                         (multiple-value-call #'%expand-cons (rest form)
  474.                           (%expand-fundefs-2 (second form))
  475.                           (%expand-list (cddr form))
  476.               ) ) ) ) ) )
  477.               (MACROLET ; Body im erweiterten Environment expandieren
  478.                 (do ((L1 (second form) (cdr L1))
  479.                      (L2 nil))
  480.                     ((atom L1)
  481.                      (if L1
  482.                        (error #+DEUTSCH "Dotted list im Code von MACROLET, endet mit ~S"
  483.                               #+ENGLISH "code after MACROLET contains a dotted list, ending with ~S"
  484.                               #+FRANCAIS "Le code de MACROLET contient une paire pointée, terminée par ~S"
  485.                               L1
  486.                        )
  487.                        (let ((*fenv* (apply #'vector (nreverse (cons *fenv* L2)))))
  488.                          (values (%expand-form (cons 'PROGN (cddr form))) t)
  489.                     )) )
  490.                   (let ((macrodef (car L1)))
  491.                     (if (and (consp macrodef)
  492.                              (symbolp (car macrodef))
  493.                              (consp (cdr macrodef))
  494.                         )
  495.                       (setq L2
  496.                         (cons (cons 'MACRO
  497.                                     (eval (make-macro-expansion macrodef))
  498.                               )
  499.                               (cons (car macrodef) L2)
  500.                       ) )
  501.                       (error #+DEUTSCH "Falsche Syntax in MACROLET: ~S"
  502.                              #+ENGLISH "illegal syntax in MACROLET: ~S"
  503.                              #+FRANCAIS "syntaxe illégale dans MACROLET : ~S"
  504.                              macrodef
  505.               ) ) ) ) )
  506.               (t
  507.                 (cond ((special-form-p f)
  508.                        ; sonstige Special-forms,
  509.                        ; z.B. IF, CATCH, THROW, PROGV, UNWIND-PROTECT, PROGN,
  510.                        ; PROG1, PROG2, WHEN, UNLESS, MULTIPLE-VALUE-LIST,
  511.                        ; MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-PROG1, AND, OR:
  512.                        (multiple-value-call #'%expand-cons form
  513.                          f nil
  514.                          (%expand-list (rest form))
  515.                       ))
  516.                       ((setq h (macro-function f)) ; globale Macro-Definition
  517.                        (values (%expand-form (funcall h form *fenv*)) t)
  518.                       )
  519.                       (t ; normaler Funktionsaufruf
  520.                        (multiple-value-call #'%expand-cons form
  521.                          f nil
  522.                          (%expand-list (rest form))
  523.             ) ) )     ))
  524.             ; f hat eine lokale Definition
  525.             (cond ((or (closurep h) (null h)); aufzurufende Funktion
  526.                    (multiple-value-call #'%expand-cons form
  527.                      f nil
  528.                      (%expand-list (rest form))
  529.                   ))
  530.                   ((and (consp h) (eq (car h) 'MACRO)) ; zu expandierender Macro
  531.                    (values (%expand-form (funcall (cdr h) form *fenv*)) t)
  532.                   ) ; Expander aufrufen
  533.                   (t (error #+DEUTSCH "Falscher Aufbau eines Function-Environment in ~S: ~S"
  534.                             #+ENGLISH "bad function environment occurred in ~S: ~S"
  535.                             #+FRANCAIS "mauvais environnement de fonction dans ~S : ~S"
  536.                             '%expand-form *fenv*
  537.         ) ) )     )  )
  538.         (if (consp f)
  539.           (multiple-value-call #'%expand-cons form
  540.             (%expand-lambda f)
  541.             (%expand-list (rest form))
  542.           )
  543.           (error #+DEUTSCH "~S: ~S ist keine korrekte Form"
  544.                  #+ENGLISH "~S: invalid form ~S"
  545.                  #+FRANCAIS "~S : forme Lisp incorrecte ~S"
  546.                  '%expand-form form
  547. ) ) ) ) ) )
  548.  
  549. #-COMPILER
  550. (progn
  551.  
  552. ; (%expand-form form) expandiert eine ganze Form. 2 Werte.
  553. (defun %expand-form (form)
  554.   (if (atom form)
  555.     (values form nil)
  556.     ; form ist CONS
  557.     (let ((f (first form)))
  558.       (if (symbolp f)
  559.         (let ((h (fenv-assoc f *fenv*)))
  560.           ; f ist in *fenv* assoziiert zu h
  561.           (if (eq h 'T)
  562.             ; f hat keine lokale Definition
  563.             (cond ((setq h (get '%expand f)) ; special forms u.ä.
  564.                    (funcall h form)
  565.                   )
  566.                   ((special-form-p f)
  567.                    ; sonstige Special-forms,
  568.                    ; z.B. IF, CATCH, THROW, PROGV, UNWIND-PROTECT, PROGN,
  569.                    ; PROG1, PROG2, WHEN, UNLESS, MULTIPLE-VALUE-LIST,
  570.                    ; MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-PROG1, AND, OR:
  571.                    (multiple-value-call #'%expand-cons form
  572.                      f nil
  573.                      (%expand-list (rest form))
  574.                   ))
  575.                   ((setq h (macro-function f)) ; globale Macro-Definition
  576.                    (values (%expand-form (funcall h form *fenv*)) t)
  577.                   )
  578.                   (t ; normaler Funktionsaufruf
  579.                    (multiple-value-call #'%expand-cons form
  580.                      f nil
  581.                      (%expand-list (rest form))
  582.             )     ))
  583.             ; f hat eine lokale Definition
  584.             (cond ((or (closurep h) (null h)); aufzurufende Funktion
  585.                    (multiple-value-call #'%expand-cons form
  586.                      f nil
  587.                      (%expand-list (rest form))
  588.                   ))
  589.                   ((and (consp h) (eq (car h) 'MACRO)) ; zu expandierender Macro
  590.                    (values (%expand-form (funcall (cdr h) form *fenv*)) t)
  591.                   ) ; Expander aufrufen
  592.                   (t (error #+DEUTSCH "Falscher Aufbau eines Function-Environment in ~S: ~S"
  593.                             #+ENGLISH "bad function environment occurred in ~S: ~S"
  594.                             #+FRANCAIS "mauvais environnement de fonction dans ~S : ~S"
  595.                             '%expand-form *fenv*
  596.         ) ) )     )  )
  597.         (if (consp f)
  598.           (multiple-value-call #'%expand-cons form
  599.             (%expand-lambda f)
  600.             (%expand-list (rest form))
  601.           )
  602.           (error #+DEUTSCH "~S: ~S ist keine korrekte Form"
  603.                  #+ENGLISH "~S: invalid form ~S"
  604.                  #+FRANCAIS "~ : forme Lisp incorrecte ~S"
  605.                  '%expand-form form
  606. ) ) ) ) ) )
  607.  
  608. ; Nun die einzelnen Expander für die Special-forms:
  609.  
  610. ; RETURN-FROM, THE, MULTIPLE-VALUE-SETQ, MULTIPLE-VALUE-BIND,
  611. ; DEFVAR, DEFPARAMETER, DEFCONSTANT:
  612. ; 1. Argument lassen, alle weiteren expandieren
  613. (defun %expand-ab2 (form)
  614.   (multiple-value-call #'%expand-cons form
  615.       (first form) nil
  616.       (multiple-value-call #'%expand-cons (rest form)
  617.           (second form) nil
  618.           (%expand-list (cddr form))
  619. ) )   )
  620. (%put '%expand 'RETURN-FROM #'%expand-ab2)
  621. (%put '%expand 'THE #'%expand-ab2)
  622. (%put '%expand 'MULTIPLE-VALUE-SETQ #'%expand-ab2)
  623. (%put '%expand 'MULTIPLE-VALUE-BIND #'%expand-ab2)
  624. (%put '%expand 'DEFVAR #'%expand-ab2)
  625. (%put '%expand 'DEFPARAMETER #'%expand-ab2)
  626. (%put '%expand 'DEFCONSTANT #'%expand-ab2)
  627.  
  628. ; QUOTE, GO, DECLARE, LOAD-TIME-VALUE: nichts expandieren
  629. (let ((fun
  630.         (function %expand-quote/go/declare (lambda (form) (values form nil)))
  631.      ))
  632.   (%put '%expand 'QUOTE fun)
  633.   (%put '%expand 'GO fun)
  634.   (%put '%expand 'DECLARE fun)
  635.   (%put '%expand 'LOAD-TIME-VALUE fun)
  636. )
  637.  
  638. ; FUNCTION:
  639. ; Falls erstes bzw. zweites Argument Liste, als Lambda-Ausdruck expandieren.
  640. (%put '%expand 'FUNCTION
  641.   (function %expand-function
  642.     (lambda (form)
  643.       (multiple-value-call #'%expand-cons form
  644.           'FUNCTION nil
  645.           (if (atom (cddr form))
  646.             (if (atom (second form))
  647.               (if (symbolp (second form))
  648.                 (let ((h (fenv-assoc (second form) *fenv*)))
  649.                   (cond ((or (eq h 'T) (closurep h) (null h)) (values (rest form) nil))
  650.                         ((and (consp h) (eq (first h) 'MACRO))
  651.                          (error #+DEUTSCH "~S: ~S unzulässig, da ~S ein lokaler Macro ist"
  652.                                 #+ENGLISH "~S: ~S is illegal since ~S is a local macro"
  653.                                 #+FRANCAIS "~S : n'est pas permis car ~S est un macro local"
  654.                                 '%expand form (second form)
  655.                         ))
  656.                         (t (error #+DEUTSCH "~S: Falscher Aufbau eines Function-Environment: ~S"
  657.                                   #+ENGLISH "~S: invalid function environment ~S"
  658.                                   #+FRANCAIS "~S : mauvais environnement de fonction ~S"
  659.                                   '%expand *fenv*
  660.                         )  )
  661.                 ) )
  662.                 (error #+DEUTSCH "~S: ~S unzulässig, da ~S kein Symbol"
  663.                        #+ENGLISH "~S: ~S is invalid since ~S is not a symbol"
  664.                        #+FRANCAIS "~S : ~S est inadmissible car ~S n'est pas un symbole"
  665.                        '%expand form (second form)
  666.               ) )
  667.               (multiple-value-call #'%expand-cons (rest form)
  668.                   (%expand-lambda (second form))
  669.                   (cddr form) nil
  670.             ) )
  671.             (multiple-value-call #'%expand-cons (rest form)
  672.                 (second form) nil
  673.                 (multiple-value-call #'%expand-cons (cddr form)
  674.                     (%expand-lambda (third form))
  675.                     (cdddr form) nil
  676.   ) ) )   ) )   )
  677. )
  678.  
  679. ; EVAL-WHEN:
  680. ; Falls die Situation COMPILE angegeben ist, führe den Body als PROGN aus,
  681. ;   gib eine Form zurück, die ohne Seiteneffekte dieselben Werte liefert.
  682. ; Sonst expandiere alle Argumente ab dem zweiten als Formen.
  683. (%put '%expand 'EVAL-WHEN
  684.   (function %expand-eval-when
  685.     (lambda (form)
  686.       (if (member 'COMPILE (second form))
  687.         (values
  688.           (list 'values-list
  689.             (list 'quote
  690.               (multiple-value-list (eval (cons 'PROGN (cddr form))))
  691.           ) )
  692.           t
  693.         )
  694.         (%expand-ab2 form)
  695.   ) ) )
  696. )
  697.  
  698. ; LET, LET*: Variablenliste und Body expandieren
  699. (let ((fun
  700.         (function %expand-let/let*
  701.           (lambda (form)
  702.             (multiple-value-call #'%expand-cons form
  703.                 (first form) nil
  704.                 (multiple-value-call #'%expand-cons (rest form)
  705.                     (%expand-varspez (second form))
  706.                     (%expand-list (cddr form))
  707.         ) ) )   )
  708.      ))
  709.   (%put '%expand 'LET fun)
  710.   (%put '%expand 'LET* fun)
  711. )
  712.  
  713. ; COMPILER-LET: Variablenliste im leeren Environment und Body expandieren
  714. (%put '%expand 'COMPILER-LET
  715.   (function %expand-compiler-let
  716.     (lambda (form)
  717.       (progv
  718.         (mapcar #'%expand-varspec-var (second form))
  719.         (mapcar #'%expand-varspec-val (second form))
  720.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  721.   ) ) )
  722. )
  723.  
  724. ; COND: Alle Teilformen der Klauseln expandieren:
  725. (%put '%expand 'cond
  726.   (function %expand-cond
  727.     (lambda (form)
  728.       (multiple-value-call #'%expand-cons form
  729.           (first form) nil
  730.           (%expand-cond (rest form))
  731.   ) ) )
  732. )
  733.  
  734. ; BLOCK: Body expandieren. Falls darin ein RETURN-FROM auf diesen Block
  735. ; vorkommt, behalte BLOCK. Sonst mache ein PROGN daraus.
  736. (%put '%expand 'block
  737.   (function %expand-block
  738.     (lambda (form)
  739.       (multiple-value-bind (body flagb) (%expand-list (cddr form))
  740.         (if (%return-p (second form) body)
  741.           (multiple-value-call #'%expand-cons form
  742.               (first form) nil
  743.               (multiple-value-call #'%expand-cons (rest form)
  744.                   (second form) nil
  745.                   body flagb
  746.           )   )
  747.           (values
  748.             (cond ((atom body) body)
  749.                   ((null (cdr body)) (car body))
  750.                   (t (cons 'progn body))
  751.             )
  752.             t
  753.   ) ) ) ) )
  754. )
  755.  
  756. ; SETQ, PSETQ: jedes zweite Argument expandieren
  757. (let ((fun
  758.         (function %expand-setq/psetq
  759.           (lambda (form)
  760.             (multiple-value-call #'%expand-cons form
  761.                 (car form) nil
  762.                 (%expand-setqlist (cdr form))
  763.         ) ) )
  764.      ))
  765.   (%put '%expand 'SETQ fun)
  766.   (%put '%expand 'PSETQ fun)
  767. )
  768.  
  769. ; TAGBODY: alle Argumente expandieren, dabei entstehende Atome weglassen
  770. (%put '%expand 'tagbody
  771.   (function %expand-tagbody
  772.     (lambda (form)
  773.       (multiple-value-call #'%expand-cons form
  774.           (first form) nil
  775.           (%expand-tagbody (rest form))
  776.   ) ) )
  777. )
  778.  
  779. ; PROGN: alle Argumente expandieren, evtl. vereinfachen.
  780. (%put '%expand 'progn
  781.   (function %expand-progn
  782.     (lambda (form)
  783.       (if (null (rest form))
  784.         (values nil t)
  785.         (if (null (cddr form))
  786.           (values (%expand-form (second form)) t)
  787.           (multiple-value-call #'%expand-cons form
  788.               (first form) nil
  789.               (%expand-list (rest form))
  790.   ) ) ) ) )
  791. )
  792.  
  793. ; FLET: Funktionsdefinitionen expandieren,
  794. ; Body im erweiterten Environment expandieren
  795. (%put '%expand 'flet
  796.   (function %expand-flet
  797.     (lambda (form)
  798.       (if (null (second form))
  799.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  800.         (let ((newfenv (%expand-fundefs-1 (second form))))
  801.           (multiple-value-call #'%expand-cons form
  802.             (car form) nil
  803.             (multiple-value-call #'%expand-cons (cdr form)
  804.               (%expand-fundefs-2 (second form))
  805.               (let ((*fenv* (apply #'vector newfenv)))
  806.                 (%expand-list (cddr form))
  807.   ) ) ) ) ) ) )
  808. )
  809.  
  810. ; LABELS: Funktionsdefinitionen und Body im erweiterten Environment expandieren
  811. (%put '%expand 'labels
  812.   (function %expand-labels
  813.     (lambda (form)
  814.       (if (null (second form))
  815.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  816.         (let ((newfenv (%expand-fundefs-1 (second form))))
  817.           (let ((*fenv* (apply #'vector newfenv)))
  818.             (multiple-value-call #'%expand-cons form
  819.               (car form) nil
  820.               (multiple-value-call #'%expand-cons (cdr form)
  821.                 (%expand-fundefs-2 (second form))
  822.                 (%expand-list (cddr form))
  823.   ) ) ) ) ) ) )
  824. )
  825.  
  826. ; MACROLET: Body im erweiterten Environment expandieren
  827. (%put '%expand 'macrolet
  828.   (function %expand-macrolet
  829.     (lambda (form)
  830.       (do ((L1 (second form) (cdr L1))
  831.            (L2 nil))
  832.           ((atom L1)
  833.            (if L1
  834.              (error #+DEUTSCH "Dotted list im Code von MACROLET, endet mit ~S"
  835.                     #+ENGLISH "code after MACROLET contains a dotted list, ending with ~S"
  836.                     #+FRANCAIS "Le code de MACROLET contient une paire pointée, terminée par ~S"
  837.                     L1
  838.              )
  839.              (let ((*fenv* (apply #'vector (nreverse (cons *fenv* L2)))))
  840.                (values (%expand-form (cons 'PROGN (cddr form))) t)
  841.           )) )
  842.         (let ((macrodef (car L1)))
  843.           (if (and (consp macrodef) (symbolp (car macrodef)) (consp (cdr macrodef)))
  844.             (setq L2
  845.               (cons (cons 'MACRO (eval (make-macro-expansion macrodef)))
  846.                     (cons (car macrodef) L2)
  847.             ) )
  848.             (error #+DEUTSCH "Falsche Syntax in MACROLET: ~S"
  849.                    #+ENGLISH "illegal syntax in MACROLET: ~S"
  850.                    #+FRANCAIS "syntaxe illégale dans MACROLET : ~S"
  851.                    macrodef
  852.   ) ) ) ) ) )
  853. )
  854.  
  855. )
  856.  
  857. ; Hilfsfunktionen für die Expansion:
  858.  
  859. ; expandiert eine Liste von Formen. 2 Werte.
  860. (defun %expand-list (l)
  861.   (if (atom l)
  862.     (if l
  863.       (error #+DEUTSCH "Dotted list im Code, endet mit ~S"
  864.              #+ENGLISH "code contains a dotted list, ending with ~S"
  865.              #+FRANCAIS "une paire pointée dans le code, terminée par ~S"
  866.              l
  867.       )
  868.       (values nil nil)
  869.     )
  870.     (multiple-value-call #'%expand-cons l
  871.                          (%expand-form (first l))
  872.                          (%expand-list (rest l))
  873. ) ) )
  874.  
  875. ; expandiert einen Funktionsnamen, der ein Cons ist (das muß ein
  876. ; Lambda-Ausdruck sein). 2 Werte.
  877. (defun %expand-lambda (l)
  878.   (unless (eq (first l) 'lambda)
  879.     (error #+DEUTSCH "~S: ~S sollte LAMBDA-Ausdruck sein"
  880.            #+ENGLISH "~S: ~S should be a lambda expression"
  881.            #+FRANCAIS "~S : ~S devrait être une expression LAMBDA"
  882.            '%expand-form l
  883.   ) )
  884.   (multiple-value-call #'%expand-cons l
  885.       'lambda nil ; LAMBDA
  886.       (%expand-lambdabody (rest l))
  887. ) )
  888.  
  889. ; expandiert den CDR eines Lambda-Ausdrucks, ein (lambdalist . body). 2 Werte.
  890. (defun %expand-lambdabody (lambdabody)
  891.   (let ((body (rest lambdabody)))
  892.     (if (and (consp body)
  893.              (let ((form (car body)))
  894.                (and (consp form)
  895.                     (eq (car form) 'DECLARE)
  896.                     (let ((declspecs (cdr form)))
  897.                       (and (consp declspecs)
  898.                            (let ((declspec (car declspecs)))
  899.                              (and (consp declspec)
  900.                                   (eq (car declspec) 'SOURCE)
  901.         )    ) )    ) )    ) )
  902.       (values lambdabody nil) ; bereits expandiert -> unberührt lassen
  903.       (values (list*
  904.                 (%expand-lambdalist (first lambdabody))
  905.                 (list 'DECLARE (list 'SOURCE lambdabody))
  906.                 (%expand-list (rest lambdabody))
  907.               )
  908.               t
  909. ) ) ) )
  910.  
  911. ; expandiert eine Lambdaliste. 2 Werte.
  912. (defun %expand-lambdalist (ll)
  913.   (if (atom ll)
  914.     (if ll
  915.       (error #+DEUTSCH "Lambdaliste darf nicht mit dem Atom ~S enden"
  916.              #+ENGLISH "lambda list must not end with the atom ~S"
  917.              #+FRANCAIS "La liste lambda ne peut pas se terminer par l'atome ~S"
  918.              ll
  919.       )
  920.       (values nil nil)
  921.     )
  922.     (multiple-value-call #'%expand-cons ll
  923.                          (%expand-parspez (first ll))
  924.                          (%expand-lambdalist (rest ll))
  925. ) ) )
  926.  
  927. ; expandiert ein Element einer Lambdaliste. 2 Werte.
  928. ; (Expandiert dabei nur bei Listen, und dann auch nur das zweite Element.)
  929. (defun %expand-parspez (ps)
  930.   (if (or (atom ps) (atom (rest ps)))
  931.     (values ps nil)
  932.     (multiple-value-call #'%expand-cons ps
  933.         (first ps) nil
  934.         (multiple-value-call #'%expand-cons (rest ps)
  935.             (%expand-form (second ps))
  936.             (cddr ps) nil
  937. ) ) )   )
  938.  
  939. ; expandiert eine Variablenliste. 2 Werte.
  940. (defun %expand-varspez (vs)
  941.   (if (atom vs)
  942.     (if vs
  943.       (error #+DEUTSCH "Variablenliste endet mit dem Atom ~S"
  944.              #+ENGLISH "variable list ends with the atom ~S"
  945.              #+FRANCAIS "La liste de variables se termine par l'atome ~S"
  946.              vs
  947.       )
  948.       (values nil nil)
  949.     )
  950.     (multiple-value-call #'%expand-cons vs
  951.         (%expand-parspez (first vs)) ; Bei Liste 2. Element expandieren
  952.         (%expand-varspez (rest vs))
  953. ) ) )
  954.  
  955. (defun %expand-varspec-var (varspec)
  956.   (if (atom varspec) varspec (first varspec))
  957. )
  958.  
  959. (defun %expand-varspec-val (varspec)
  960.   (if (atom varspec) nil (eval (second varspec)))
  961. )
  962.  
  963. ; Expandiert eine Cond-Klausel-Liste. 2 Werte.
  964. (defun %expand-cond (clauses)
  965.   (if (atom clauses)
  966.     (values clauses nil)
  967.     (multiple-value-call #'%expand-cons clauses
  968.         (%expand-list (first clauses))
  969.         (%expand-cond (rest clauses))
  970. ) ) )
  971.  
  972. ; Auf den bereits expandierten Body wird folgendes angewandt:
  973. ; (%return-p name list) stellt fest, ob die Formenliste list irgendwo ein
  974. ; (RETURN-FROM name ...) enthält.
  975. (defun %return-p (name body)
  976.   (block return-p
  977.     (tagbody 1
  978.       (if (atom body) (return-from return-p nil))
  979.       (let ((form (car body)))
  980.         (if
  981.           ; stelle fest, ob form ein (RETURN-FROM name ...) enthält:
  982.           (and (consp form)
  983.                (or (and (eq (first form) 'return-from) ; (RETURN-FROM name ...)
  984.                         (eq (second form) name)
  985.                    )
  986.                    (and (consp (first form))           ; Lambdaliste
  987.                         (%return-p name (first form))
  988.                    )
  989.                    (and (not ; keine neue Definition desselben Blocks ?
  990.                           (and (eq (first form) 'block) (eq (second form) name))
  991.                         )
  992.                         (%return-p name (rest form)) ; Funktionsaufruf
  993.           )    )   )
  994.           (return-from return-p t)
  995.       ) )
  996.       (setq body (cdr body))
  997.       (go 1)
  998. ) ) )
  999.  
  1000. (defun %expand-setqlist (l)
  1001.   (if (or (atom l) (atom (cdr l)))
  1002.     (values l nil)
  1003.     (multiple-value-call #'%expand-cons l
  1004.         (first l) nil
  1005.         (multiple-value-call #'%expand-cons (rest l)
  1006.             (%expand-form (second l))
  1007.             (%expand-setqlist (cddr l))
  1008. ) ) )   )
  1009.  
  1010. ; (%expand-tagbody list) expandiert die Elemente einer Liste und läßt dabei
  1011. ; entstehende Atome fest (damit keine neuen Tags entstehen, die andere Tags
  1012. ; verdecken könnten). 2 Werte.
  1013. (defun %expand-tagbody (body)
  1014.   (cond ((atom body) (values body nil))
  1015.         ((atom (first body))
  1016.          (multiple-value-call #'%expand-cons body
  1017.              (first body) nil
  1018.              (%expand-tagbody (rest body))
  1019.         ))
  1020.         (t (multiple-value-bind (exp flag) (%expand-form (first body))
  1021.              (if (atom exp)
  1022.                (values (%expand-tagbody (rest body)) t) ; weglassen
  1023.                (multiple-value-call #'%expand-cons body
  1024.                    exp flag
  1025.                    (%expand-tagbody (rest body))
  1026. ) )     )  ) ) )
  1027. ; (%expand-fundefs-1 fundefs) liefert eine Liste (name1 nil ... namek nil *fenv*)
  1028. (defun %expand-fundefs-1 (fundefs)
  1029.   (if (atom fundefs)
  1030.     (if fundefs
  1031.       (error #+DEUTSCH "FLET/LABELS: Dotted list im Code, endet mit ~S"
  1032.              #+ENGLISH "FLET/LABELS: code contains a dotted list, ending with ~S"
  1033.              #+FRANCAIS "FLET/LABELS : une paire pointée dans le code, terminée par ~S"
  1034.              fundefs
  1035.       )
  1036.       (list *fenv*)
  1037.     )
  1038.     (let ((fundef (car fundefs)))
  1039.       (if (and (consp fundef) (symbolp (car fundef)) (consp (cdr fundef)))
  1040.         (list* (car fundef) nil (%expand-fundefs-1 (cdr fundefs)))
  1041.         (error #+DEUTSCH "Falsche Syntax in FLET/LABELS: ~S"
  1042.                #+ENGLISH "illegal syntax in FLET/LABELS: ~S"
  1043.                #+FRANCAIS "syntaxe incorrecte dans FLET/LABELS : ~S"
  1044.                fundef
  1045. ) ) ) ) )
  1046. ; (%expand-fundefs-2 fundefs) expandiert eine Funktionsdefinitionenliste,
  1047. ; wie in FLET, LABELS. 2 Werte.
  1048. (defun %expand-fundefs-2 (fundefs)
  1049.   (if (atom fundefs)
  1050.     (values fundefs nil)
  1051.     (let ((fundef (car fundefs)))
  1052.       (multiple-value-call #'%expand-cons fundefs
  1053.              (multiple-value-call #'%expand-cons fundef
  1054.                      (car fundef) nil
  1055.                      (%expand-lambdabody (cdr fundef))
  1056.              )
  1057.              (%expand-fundefs-2 (rest fundefs))
  1058. ) ) ) )
  1059.  
  1060. #|
  1061. ; expandiert eine Form in einem gegebenen Function-Environment
  1062. ; Kann bei Bedarf von EVAL aufgerufen werden.
  1063. (defun %expand-form-main (form *fenv*)
  1064.   (%expand-form form)
  1065. )
  1066. |#
  1067.  
  1068. ; expandiert (lambdalist . body) in einem gegebenen Function-Environment.
  1069. ; Wird von GET_CLOSURE aufgerufen.
  1070. (defun %expand-lambdabody-main (lambdabody *fenv*)
  1071.   (%expand-lambdabody lambdabody)
  1072. )
  1073.  
  1074. (VALUES) )
  1075.  
  1076. ;; ab hier ist FUNCTION funktionsfähig, soweit kein MACROLET darin vorkommt.
  1077.  
  1078. (PROGN
  1079.  
  1080. (proclaim '(special *load-paths*))
  1081. (setq *load-paths* nil)
  1082.  
  1083. ; vorläufig brauchen die Files nicht gesucht zu werden:
  1084. (defun search-file (filename extensions)
  1085.   (mapcan #'(lambda (extension)
  1086.               (let ((filename (merge-pathnames filename extension)))
  1087.                 (if (probe-file filename) (list filename) '())
  1088.             ) )
  1089.           (reverse extensions)
  1090. ) )
  1091.  
  1092. (proclaim '(special *load-verbose*))
  1093. (setq *load-verbose* t)
  1094. (proclaim '(special *load-print*))
  1095. (setq *load-print* nil)
  1096. (proclaim '(special *load-echo*))
  1097. (setq *load-echo* nil)
  1098.  
  1099. ; (LOAD filename [:verbose] [:print] [:if-does-not-exist] [:echo] [:compiling]),
  1100. ; CLTL S. 426
  1101. (fmakunbound 'load)
  1102. (defun load (filename
  1103.              &key (verbose *load-verbose*) (print *load-print*) (if-does-not-exist t)
  1104.                   (echo *load-echo*) (compiling nil))
  1105.   (let ((stream
  1106.           (if (streamp filename)
  1107.             filename
  1108.             (or (open (setq filename (pathname filename))
  1109.                   :direction :input
  1110.                   :element-type 'string-char
  1111.                   :if-does-not-exist nil
  1112.                 )
  1113.                 ; Datei mit genau diesem Namen nicht vorhanden.
  1114.                 ; Suche unter den Dateien mit demselben Namen und den
  1115.                 ; Extensions "LSP", "FAS" die neueste:
  1116.                 (let ((present-files
  1117.                         (search-file filename '(#".lsp" #".fas"))
  1118.                      ))
  1119.                   (if (endp present-files)
  1120.                     nil
  1121.                     (open (setq filename (first present-files))
  1122.                           :direction :input :element-type 'string-char
  1123.        )) ) )   ) ) )
  1124.     (if stream
  1125.       (let ((input-stream
  1126.               (if echo
  1127.                 (make-echo-stream stream *standard-output*)
  1128.                 stream
  1129.             ) )
  1130.             ; :verbose, :print und :echo wirken nicht rekursiv - dazu
  1131.             ; hat man ja gerade die Special-Variablen *load-verbose* etc.
  1132.             ;(*load-verbose* verbose)
  1133.             ;(*load-print* print)
  1134.             ;(*load-echo* echo)
  1135.             (*package* *package*) ; *PACKAGE* binden
  1136.             (*readtable* *readtable*) ; *READTABLE* binden
  1137.             (end-of-file "EOF")) ; einmaliges Objekt
  1138.         (when verbose
  1139.           (fresh-line)
  1140.           (write-string #+DEUTSCH ";; Datei "
  1141.                         #+ENGLISH ";; Loading file "
  1142.                         #+FRANCAIS ";; Chargement du fichier "
  1143.           )
  1144.           (princ filename)
  1145.           (write-string #+DEUTSCH " wird geladen..."
  1146.                         #+ENGLISH " ..."
  1147.                         #+FRANCAIS " ..."
  1148.         ) )
  1149.         (block nil
  1150.           (unwind-protect
  1151.             (tagbody weiter
  1152.               (when echo (fresh-line))
  1153.               (let ((obj (read input-stream nil end-of-file)))
  1154.                 (when (eql obj end-of-file) (return-from nil))
  1155.                 (setq obj
  1156.                   (cond ((compiled-function-p obj) (funcall obj))
  1157.                         (compiling (funcall (compile-form obj nil nil nil nil nil)))
  1158.                         (t (eval obj))
  1159.                 ) )
  1160.                 (when print (print obj))
  1161.               )
  1162.               (go weiter)
  1163.             )
  1164.             (close stream) (close input-stream)
  1165.         ) )
  1166.         (when verbose
  1167.           (fresh-line)
  1168.           (write-string #+DEUTSCH ";; Datei "
  1169.                         #+ENGLISH ";; Loading of file "
  1170.                         #+FRANCAIS ";; Le fichier "
  1171.           )
  1172.           (princ filename)
  1173.           (write-string #+DEUTSCH " ist geladen."
  1174.                         #+ENGLISH " is finished."
  1175.                         #+FRANCAIS " est chargé."
  1176.         ) )
  1177.         t
  1178.       )
  1179.       (if if-does-not-exist
  1180.         (error #+DEUTSCH "Ein Datei mit Namen ~A gibt es nicht."
  1181.                #+ENGLISH "A file with name ~A does not exist"
  1182.                #+FRANCAIS "Il n'existe pas de fichier de nom ~A."
  1183.                filename
  1184.         )
  1185.         nil
  1186.       )
  1187. ) ) )
  1188.  
  1189. ; vorläufig:
  1190. (sys::%putd 'defun
  1191.   (cons 'sys::macro
  1192.     (function defun
  1193.       (lambda (form env)
  1194.         (unless (and (consp (cdr form)) (consp (cddr form)))
  1195.           (error #+DEUTSCH "~S: Funktionsname und/oder Parameterliste fehlt"
  1196.                  #+ENGLISH "~S: missing function name and/or parameter list"
  1197.                  #+FRANCAIS "~S : Le nom de fonction et/ou la liste de paramètre manque"
  1198.                  'defun
  1199.         ) )
  1200.         (let ((name (cadr form))
  1201.               (lambdalist (caddr form))
  1202.               (body (cdddr form)))
  1203.           (unless (symbolp name)
  1204.             (error #+DEUTSCH "~S: ~S ist kein Symbol."
  1205.                    #+ENGLISH "~S: ~S is not a symbol."
  1206.                    #+FRANCAIS "~S : ~S n'est pas un symbole."
  1207.                    'defun name
  1208.           ) )
  1209.           (when (special-form-p name)
  1210.             (error #+DEUTSCH "~S: Spezialform ~S kann nicht umdefiniert werden."
  1211.                    #+ENGLISH "~S: special form ~S cannot be redefined."
  1212.                    #+FRANCAIS "~S : La forme spéciale ~S ne peut pas être redéfinie."
  1213.                    'defun name
  1214.           ) )
  1215.           (multiple-value-bind (body-rest declarations docstring)
  1216.                                (sys::parse-body body t env)
  1217.             (declare (ignore docstring))
  1218.             (if declarations
  1219.               (setq declarations (list (cons 'DECLARE declarations)))
  1220.             )
  1221.             #|
  1222.             `(PROGN
  1223.                (SYS::%PUT ',name 'SYS::DEFINITION ',form)
  1224.                (SYS::%PUTD ',name
  1225.                  (LABELS ((,name ,lambdalist ,@declarations
  1226.                             (BLOCK ,name ,@body-rest)
  1227.                          ))
  1228.                    (FUNCTION ,name)
  1229.                ) )
  1230.                ',name
  1231.              )
  1232.             |#
  1233.             (list 'progn
  1234.               (list 'sys::%put (list 'quote name) ''sys::definition
  1235.                     (list 'quote form)
  1236.               )
  1237.               (list 'sys::%putd (list 'quote name)
  1238.                 (list 'labels
  1239.                   (list
  1240.                     (list* name lambdalist
  1241.                       (append declarations
  1242.                         (list (list* 'BLOCK name body-rest))
  1243.                   ) ) )
  1244.                   (list 'function name)
  1245.               ) )
  1246.               (list 'quote name)
  1247.             )
  1248.     ) ) ) )
  1249. ) )
  1250.  
  1251. ; vorläufige Definition des Macros DO :
  1252. (sys::%putd 'do
  1253.   (cons 'sys::macro
  1254.     (function do
  1255.       (lambda (form env)
  1256.         (let ((varclauselist (second form))
  1257.               (exitclause (third form))
  1258.               (body (cdddr form)))
  1259.           (when (atom exitclause)
  1260.             (error #+DEUTSCH "Exitclause in ~S muß Liste sein."
  1261.                    #+ENGLISH "exit clause in ~S must be a list"
  1262.                    #+FRANCAIS "La clause de sortie dans ~S doit être une liste."
  1263.                    'do
  1264.           ) )
  1265.           (let ((bindlist nil)
  1266.                 (reinitlist nil)
  1267.                 (bodytag (gensym))
  1268.                 (exittag (gensym)))
  1269.             (multiple-value-bind (body-rest declarations)
  1270.                                  (sys::parse-body body nil env)
  1271.               (block do
  1272.                 (tagbody 1
  1273.                   (when (atom varclauselist)
  1274.                     (return-from do
  1275.                       #|
  1276.                       `(block nil
  1277.                          (let ,(nreverse bindlist)
  1278.                            (declare ,@declarations)
  1279.                            (tagbody
  1280.                              (go ,exittag)
  1281.                              ,bodytag
  1282.                              ,@body-rest
  1283.                              (psetq ,@(nreverse reinitlist))
  1284.                              ,exittag
  1285.                              (or ,(first exitclause) (go ,bodytag))
  1286.                              (return-from nil (progn ,@(rest exitclause)))
  1287.                        ) ) )
  1288.                       |#
  1289.                       (list 'block 'nil
  1290.                         (list 'let (nreverse bindlist)
  1291.                           (cons 'declare declarations)
  1292.                           (list* 'tagbody
  1293.                             (list 'go exittag)
  1294.                             bodytag
  1295.                             (append body-rest
  1296.                               (list
  1297.                                 (cons 'psetq (nreverse reinitlist))
  1298.                                 exittag
  1299.                                 (list 'or (first exitclause) (list 'go bodytag))
  1300.                                 (list 'return-from 'nil
  1301.                                   (cons 'progn (rest exitclause))
  1302.                       ) ) ) ) ) )
  1303.                   ) )
  1304.                   (let ( (varclause (first varclauselist)) )
  1305.                        (setq varclauselist (rest varclauselist))
  1306.                        (cond ( (atom varclause)
  1307.                                   (setq bindlist
  1308.                                         (cons varclause bindlist)) )
  1309.                              ( (atom (cdr varclause))
  1310.                                   (setq bindlist
  1311.                                         (cons (first varclause) bindlist)) )
  1312.                              ( (atom (cddr varclause))
  1313.                                   (setq bindlist
  1314.                                         (cons varclause bindlist)) )
  1315.                              ( t (setq bindlist
  1316.                                        (cons (list (first varclause)
  1317.                                                    (second varclause))
  1318.                                              bindlist))
  1319.                                  (setq reinitlist
  1320.                                        (list* (third varclause)
  1321.                                               (first varclause)
  1322.                                               reinitlist)) )))
  1323.                   (go 1)
  1324.     ) ) ) ) ) ) )
  1325. ) )
  1326.  
  1327. ; vorläufige Definition des Macros DOTIMES :
  1328. (sys::%putd 'dotimes
  1329.   (cons 'sys::macro
  1330.     (function dotimes
  1331.       (lambda (form env)
  1332.         (let ((var (first (second form)))
  1333.               (countform (second (second form)))
  1334.               (resultform (third (second form)))
  1335.               (body (cddr form)))
  1336.           (multiple-value-bind (body-rest declarations)
  1337.                                (sys::parse-body body nil env)
  1338.             (let ((g (gensym)))
  1339.               #|
  1340.               `(DO ((,var 0 (1+ ,var))
  1341.                     (,g ,countform))
  1342.                    ((>= ,var ,g) ,resultform)
  1343.                  (declare ,@declarations)
  1344.                  ,@body-rest
  1345.                )
  1346.               |#
  1347.               (list* 'do (list (list var '0 (list '1+ var)) (list g countform))
  1348.                          (list (list '>= var g) resultform)
  1349.                      (cons 'declare declarations)
  1350.                      body-rest
  1351.               )
  1352.     ) ) ) ) )
  1353. ) )
  1354.  
  1355. (VALUES) )
  1356.  
  1357. ;; ab hier sind LOAD, DEFUN, DO, DOTIMES (eingeschränkt) funktionsfähig.
  1358.  
  1359. (LOAD "defseq")   ;; Definitionen von Standard-Sequences
  1360.  
  1361. (LOAD "backquot") ;; Backquote-Readmacro
  1362.  
  1363. (PROGN
  1364.  
  1365. (sys::%putd 'sys::backquote
  1366.   (cons 'sys::macro
  1367.     (function sys::backquote
  1368.       (lambda (form &optional env) (declare (ignore env)) (third form))
  1369. ) ) )
  1370.  
  1371. (VALUES) )
  1372.  
  1373. ;; ab hier ist Backquote funktionsfähig
  1374.  
  1375. (LOAD "defmacro")
  1376.  
  1377. ;; ab hier ist FUNCTION (uneingeschränkt) funktionsfähig.
  1378.  
  1379. (PROGN
  1380.  
  1381. (sys::%putd 'defmacro
  1382.   (cons 'sys::macro
  1383.     (function defmacro
  1384.       (lambda (form &optional env)
  1385.         (declare (ignore env))
  1386.         (multiple-value-bind (expansion name lambdalist docstring)
  1387.                              (sys::make-macro-expansion (cdr form))
  1388.           (declare (ignore lambdalist))
  1389.           `(PROGN
  1390.              (EVAL-WHEN (COMPILE LOAD EVAL)
  1391.                (SYSTEM::REMOVE-OLD-DEFINITIONS ',name)
  1392.                ,@(if docstring
  1393.                    `((SYSTEM::%SET-DOCUMENTATION ',name 'FUNCTION ',docstring))
  1394.                    '()
  1395.                  )
  1396.                (SYSTEM::%PUTD ',name (CONS 'SYSTEM::MACRO ,expansion))
  1397.              )
  1398.              (EVAL-WHEN (EVAL) (SYSTEM::%PUT ',name 'SYSTEM::DEFINITION ',form))
  1399.              ',name
  1400.            )
  1401.     ) ) )
  1402. ) )
  1403.  
  1404. (sys::%putd 'defun
  1405.   (cons 'sys::macro
  1406.     (function defun
  1407.       (lambda (form env)
  1408.         (if (atom (cdr form))
  1409.           (error #+DEUTSCH "~S: Daraus kann keine Funktion definiert werden: ~S"
  1410.                  #+ENGLISH "~S: cannot define a function from that: ~S"
  1411.                  #+FRANCAIS "~S : Pas de définition de fonction possible à partir de: ~S"
  1412.                  'defun (cdr form)
  1413.         ) )
  1414.         (unless (symbolp (cadr form))
  1415.           (error #+DEUTSCH "~S: Der Name einer Funktion muß ein Symbol sein, nicht: ~S"
  1416.                  #+ENGLISH "~S: the name of a function must be a symbol, not ~S"
  1417.                  #+FRANCAIS "~S : Le nom d'une fonction doit être un symbole et non ~S"
  1418.                  'defun (cadr form)
  1419.         ) )
  1420.         (if (atom (cddr form))
  1421.           (error #+DEUTSCH "~S: Die Funktion ~S hat keine Lambdaliste."
  1422.                  #+ENGLISH "~S: function ~S is missing a lambda list"
  1423.                  #+FRANCAIS "~S : Il manque une liste lambda à la fonction ~S."
  1424.                  'defun (cadr form)
  1425.         ) )
  1426.         (let ((name (cadr form))
  1427.               (lambdalist (caddr form))
  1428.               (body (cdddr form)))
  1429.           (multiple-value-bind (body-rest declarations docstring)
  1430.                                (sys::parse-body body t env)
  1431.             (if declarations
  1432.               (setq declarations (list (cons 'DECLARE declarations)))
  1433.             )
  1434.             (let ((lambdabody
  1435.                     `(,lambdalist ,@declarations (BLOCK ,name ,@body-rest))
  1436.                  ))
  1437.               `(PROGN
  1438.                  (EVAL-WHEN (COMPILE)
  1439.                    (COMPILER::C-DEFUN ',name
  1440.                      ,@(if (and compiler::*compiling*
  1441.                                 compiler::*compiling-from-file*
  1442.                                 (member name compiler::*inline-functions* :test #'eq)
  1443.                                 (null compiler::*venv*)
  1444.                                 (null compiler::*fenv*)
  1445.                                 (null compiler::*benv*)
  1446.                                 (null compiler::*genv*)
  1447.                                 (eql compiler::*denv* *toplevel-denv*)
  1448.                            )
  1449.                          ; Lambdabody für Inline-Compilation aufheben:
  1450.                          `(',lambdabody)
  1451.                          '()
  1452.                        )
  1453.                  ) )
  1454.                  (SYSTEM::REMOVE-OLD-DEFINITIONS ',name)
  1455.                  ,@(if docstring
  1456.                      `((SYSTEM::%SET-DOCUMENTATION ',name 'FUNCTION ',docstring))
  1457.                      '()
  1458.                    )
  1459.                  (SYSTEM::%PUTD ',name
  1460.                    (LABELS ((,name ,@lambdabody))
  1461.                      (FUNCTION ,name)
  1462.                  ) )
  1463.                  (EVAL-WHEN (EVAL) (SYSTEM::%PUT ',name 'SYSTEM::DEFINITION ',form))
  1464.                  ',name
  1465.                )
  1466.     ) ) ) ) )
  1467. ) )
  1468.  
  1469. (VALUES) )
  1470.  
  1471. ;; ab hier sind DEFMACRO und DEFUN funktionsfähig.
  1472.  
  1473. ; (MACRO-EXPANDER . macrodef)                                         [Macro]
  1474. ; expandiert zum Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)).
  1475. (defmacro MACRO-EXPANDER (&body macrodef)
  1476.   (make-macro-expansion macrodef)
  1477. )
  1478.  
  1479. (LOAD "macros1")  ;; Kontrollstrukturen - Macros
  1480. (LOAD "macros2")  ;; weitere Macros
  1481.  
  1482. (LOAD "defs1")    ;; Definitionen zu Symbolen, Zahlen, Characters, Zeit
  1483.  
  1484. #+CLISP1 (LOAD "array") ;; Hilfsfunktionen für Arrays
  1485.  
  1486. (LOAD "places")   ;; SETF-Places: Definitionen und Macros
  1487.  
  1488. ;; ab hier ist SETF u.ä. funktionsfähig.
  1489.  
  1490. (LOAD "floatpri") ;; Ausgabe von Floating-Points
  1491.  
  1492. (LOAD "type")     ;; TYPEP
  1493.  
  1494. (LOAD "defstruc") ;; DEFSTRUCT-Macro
  1495.  
  1496. (LOAD "format")   ;; FORMAT
  1497.  
  1498. ; Ein Stückchen "DO-WHAT-I-MEAN":
  1499. ; Sucht ein Programm-File.
  1500. ; Gesucht wird im aktuellen Directory und dann in den Directories
  1501. ; aus *load-paths*.
  1502. ; Ist eine Extension angegeben, so wird nur nach Files mit genau dieser
  1503. ; Extension gesucht. Ist keine Extension angegeben, so wird nur nach Files
  1504. ; mit einer Extension aus der gegebenen Liste gesucht.
  1505. ; Man erhält alle Files aus dem ersten passenden Directory, als Pathnames,
  1506. ; in einer Liste, nach fallendem FILE-WRITE-DATE sortiert, oder NIL.
  1507. (defun search-file (filename extensions
  1508.                     &aux (use-extensions (null (pathname-type filename))) )
  1509.   (when use-extensions
  1510.     (setq extensions ; Case-Konversionen auf den Extensions durchführen
  1511.       (mapcar #'pathname-type extensions)
  1512.   ) )
  1513.   ; Defaults einmergen:
  1514.   (setq filename (merge-pathnames filename '#".*"))
  1515.   ; Suchen:
  1516.   (let ((already-searched nil))
  1517.     (dolist (dir (cons '#""
  1518.                        ; Wenn filename ".." enthält, zählt *load-paths* nicht
  1519.                        ; (um Errors wegen ".../../foo" z.B. auf DOS zu vermeiden):
  1520.                        (if (member #+(or ATARI DOS AMIGA VMS) :PARENT
  1521.                                    #+(or UNIX OS/2) ".."
  1522.                                    (pathname-directory filename)
  1523.                                    :test #'equal
  1524.                            )
  1525.                          '()
  1526.                          *load-paths*
  1527.             )    )     )
  1528.       (let ((search-filename
  1529.               (merge-pathnames (merge-pathnames filename dir))
  1530.            ))
  1531.         (unless (member search-filename already-searched :test #'equal)
  1532.           (let ((xpathnames (directory search-filename :full t)))
  1533.             (when use-extensions
  1534.               ; nach passenden Extensions filtern:
  1535.               (setq xpathnames
  1536.                 (delete-if-not ; hat xpathname eine der gegebenen Extensions?
  1537.                   #'(lambda (xpathname)
  1538.                       (member (pathname-type (first xpathname)) extensions
  1539.                               :test #-(or AMIGA OS/2) #'string=
  1540.                                     #+(or AMIGA OS/2) #'string-equal
  1541.                     ) )
  1542.                   xpathnames
  1543.             ) ) )
  1544.             (when xpathnames
  1545.               ; nach Datum sortiert, zurückgeben:
  1546.               (dolist (xpathname xpathnames)
  1547.                 (setf (rest xpathname)
  1548.                       (apply #'encode-universal-time (third xpathname))
  1549.               ) )
  1550.               (return (mapcar #'first (sort xpathnames #'> :key #'rest)))
  1551.           ) )
  1552.           (push search-filename already-searched)
  1553.     ) ) )
  1554. ) )
  1555.  
  1556. (LOAD "user1")    ;; User-Interface, Teil 1: Break-Loop, Stepper
  1557.  
  1558. (LOAD "user2")    ;; User-Interface, Teil 2: Apropos, Describe, Dribble, Ed
  1559.  
  1560. (LOAD "trace")    ;; User-Interface, Teil 3: TRACE
  1561.  
  1562. ;(LOAD "macros3")  ;; weitere Macros, optional
  1563.  
  1564. (LOAD "config")   ;; Konfigurations-Parameter
  1565.  
  1566. (LOAD "compiler") ;; Compiler
  1567.  
  1568. (LOAD "defs2")    ;; CLtL2-Definitionen, optional
  1569.  
  1570. (when (find-symbol "MAKE-WINDOW" "SYSTEM")
  1571.   (LOAD "screen") ;; Screen-Paket, optional
  1572. )
  1573.  
  1574. #+AMIGA (LOAD "rexx") ;; Rexx-Schnittstelle, optional
  1575.  
  1576. #+ATARI
  1577. (when (y-or-n-p #+DEUTSCH "Editor laden?"
  1578.                 #+ENGLISH "Load editor?"
  1579.                 #+FRANCAIS "Charger l'éditeur?"
  1580.       )
  1581.   (LOAD "editor") ;; Editor
  1582. )
  1583.  
  1584. (in-package "USER") ;; Default-Package aktuell machen
  1585.  
  1586.